home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / alpha.pso < prev    next >
Encoding:
Text File  |  1992-02-17  |  18.1 KB  |  434 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
  2.  
  3. ; This file was generated by Pseudoscheme 2.8a
  4. ;  running in Lucid Common Lisp 4.0.1
  5. ;  from file /amd/night/b/jar/pseudo/alpha.scm
  6.  
  7. (SCHI:BEGIN-TRANSLATED-FILE)
  8. (DEFUN NOTE-CONTEXT!
  9.        (CONTEXT NODE)
  10.        (FUNCALL CONTEXT NODE))
  11. (SCHI:SET-VALUE-FROM-FUNCTION 'NOTE-CONTEXT!
  12.                               'SCHEME::NOTE-CONTEXT!)
  13. (LOCALLY (DECLARE (SPECIAL VALUE-CONTEXT
  14.                            SET-VALUE-REFS!))
  15.          (SETQ VALUE-CONTEXT SET-VALUE-REFS!))
  16. (SCHI:SET-FUNCTION-FROM-VALUE 'VALUE-CONTEXT
  17.                               'SCHEME::VALUE-CONTEXT)
  18. (LOCALLY (DECLARE (SPECIAL PROCEDURE-CONTEXT
  19.                            SET-PROC-REFS!))
  20.          (SETQ PROCEDURE-CONTEXT SET-PROC-REFS!))
  21. (SCHI:SET-FUNCTION-FROM-VALUE 'PROCEDURE-CONTEXT
  22.                               'SCHEME::PROCEDURE-CONTEXT)
  23. (LOCALLY (DECLARE (SPECIAL LVALUE-CONTEXT
  24.                            SET-ASSIGNED!))
  25.          (SETQ LVALUE-CONTEXT SET-ASSIGNED!))
  26. (SCHI:SET-FUNCTION-FROM-VALUE 'LVALUE-CONTEXT
  27.                               'SCHEME::LVALUE-CONTEXT)
  28. (DEFUN DEFINE-CONTEXT
  29.        (VAR)
  30.        VAR
  31.        'SCHEME::DEFINE-CONTEXT)
  32. (SCHI:SET-VALUE-FROM-FUNCTION 'DEFINE-CONTEXT
  33.                               'SCHEME::DEFINE-CONTEXT)
  34. (DEFUN TOP-LEVEL-CONTEXT
  35.        (VAR)
  36.        VAR
  37.        'SCHEME::TOP-LEVEL-CONTEXT)
  38. (SCHI:SET-VALUE-FROM-FUNCTION 'TOP-LEVEL-CONTEXT
  39.                               'SCHEME::TOP-LEVEL-CONTEXT)
  40. (DEFUN LOSE
  41.        (CONTEXT)
  42.        (DECLARE (SPECIAL VALUE-CONTEXT))
  43.        CONTEXT
  44.        VALUE-CONTEXT)
  45. (SCHI:SET-VALUE-FROM-FUNCTION 'LOSE 'SCHEME::LOSE)
  46. (LOCALLY (DECLARE (SPECIAL @FREE-VARIABLES))
  47.          (SETQ @FREE-VARIABLES (MAKE-FLUID 'NIL)))
  48. (SCHI:SET-FUNCTION-FROM-VALUE '@FREE-VARIABLES
  49.                               'SCHEME::@FREE-VARIABLES)
  50. (DEFUN ALPHA-TOP
  51.        (FORM S-ENV)
  52.        (DECLARE (SPECIAL TOP-LEVEL-CONTEXT))
  53.        (ALPHA FORM S-ENV TOP-LEVEL-CONTEXT))
  54. (SCHI:SET-VALUE-FROM-FUNCTION 'ALPHA-TOP
  55.                               'SCHEME::ALPHA-TOP)
  56. (LOCALLY (DECLARE (SPECIAL @WHERE))
  57.          (SETQ @WHERE (MAKE-FLUID 'SCHEME::<TOP>)))
  58. (SCHI:SET-FUNCTION-FROM-VALUE '@WHERE 'SCHEME::@WHERE)
  59. (DEFUN ALPHA
  60.        (FORM S-ENV CONTEXT)
  61.        (DECLARE (SPECIAL ALPHATIZERS))
  62.        (WITH-VALUES #'(LAMBDA NIL
  63.                               (CLASSIFY FORM S-ENV))
  64.                     #'(LAMBDA (CLASS FORM@0 S-ENV@1)
  65.                        (FUNCALL (SVREF ALPHATIZERS CLASS) FORM@0 S-ENV@1
  66.                         CONTEXT))))
  67. (SCHI:SET-VALUE-FROM-FUNCTION 'ALPHA 'SCHEME::ALPHA)
  68. (LOCALLY (DECLARE (SPECIAL ALPHATIZERS
  69.                            NUMBER-OF-CLASSES))
  70.          (SETQ ALPHATIZERS (MAKE-VECTOR NUMBER-OF-CLASSES)))
  71. (SCHI:SET-FUNCTION-FROM-VALUE 'ALPHATIZERS
  72.                               'SCHEME::ALPHATIZERS)
  73. (DEFUN DEFINE-ALPHATIZER
  74.        (CLASS PROC)
  75.        (DECLARE (SPECIAL ALPHATIZERS))
  76.        (SETF (SVREF ALPHATIZERS CLASS) PROC)
  77.        SCHI:UNSPECIFIED)
  78. (SCHI:SET-VALUE-FROM-FUNCTION 'DEFINE-ALPHATIZER
  79.                               'SCHEME::DEFINE-ALPHATIZER)
  80. (SCHI:AT-TOP-LEVEL
  81.   (LOCALLY (DECLARE (SPECIAL CLASS/LITERAL))
  82.            (DEFINE-ALPHATIZER CLASS/LITERAL
  83.                               #'(LAMBDA (.EXP S-ENV CONTEXT) S-ENV CONTEXT
  84.                                  (MAKE-CONSTANT .EXP SCHI:FALSE)))))
  85. (SCHI:AT-TOP-LEVEL
  86.   (LOCALLY (DECLARE (SPECIAL @FREE-VARIABLES CLASS/NAME))
  87.            (DEFINE-ALPHATIZER CLASS/NAME
  88.                               #'(LAMBDA (.EXP S-ENV CONTEXT)
  89.                                  (LET ((DENOTATION (LOOKUP S-ENV .EXP)))
  90.                                   (IF (SCHI:TRUEP (NODE? DENOTATION))
  91.                                    (PROGN
  92.                                     (IF
  93.                                      (SCHI:TRUEP (LOCAL-VARIABLE? DENOTATION))
  94.                                      (NOTE-CONTEXT! CONTEXT DENOTATION)
  95.                                      (LET ((FREE (FLUID @FREE-VARIABLES)))
  96.                                       (IF
  97.                                        (NOT
  98.                                         (MEMBER DENOTATION FREE :TEST #'EQ))
  99.                                        (SET-FLUID! @FREE-VARIABLES
  100.                                         (CONS DENOTATION FREE)))))
  101.                                     DENOTATION)
  102.                                    (ALPHA
  103.                                     (SYNTAX-ERROR
  104.                                      "syntactic keyword in invalid position"
  105.                                      .EXP)
  106.                                     S-ENV CONTEXT)))))))
  107. (SCHI:AT-TOP-LEVEL
  108.   (LOCALLY
  109.     (DECLARE (SPECIAL VALUE-CONTEXT
  110.                       PROCEDURE-CONTEXT
  111.                       CLASS/APPLICATION))
  112.     (DEFINE-ALPHATIZER CLASS/APPLICATION
  113.                        #'(LAMBDA (.EXP S-ENV CONTEXT) CONTEXT
  114.                           (MAKE-CALL
  115.                            (ALPHA (CAR .EXP) S-ENV PROCEDURE-CONTEXT)
  116.                            (MAPCAR
  117.                             #'(LAMBDA (ARG) (ALPHA ARG S-ENV VALUE-CONTEXT))
  118.                             (CDR .EXP)))))))
  119. (SCHI:AT-TOP-LEVEL
  120.   (LOCALLY (DECLARE (SPECIAL CLASS/QUOTE))
  121.            (DEFINE-ALPHATIZER CLASS/QUOTE
  122.                               #'(LAMBDA (.EXP S-ENV CONTEXT) S-ENV CONTEXT
  123.                                  (MAKE-CONSTANT (CADR .EXP) SCHI:TRUE)))))
  124. (SCHI:AT-TOP-LEVEL
  125.   (LOCALLY
  126.     (DECLARE
  127.       (SPECIAL VALUE-CONTEXT
  128.                SET-CLOSED-OVER!
  129.                PROCEDURE-CONTEXT
  130.                CLASS/LAMBDA))
  131.     (DEFINE-ALPHATIZER CLASS/LAMBDA
  132.                        #'(LAMBDA (.EXP S-ENV CONTEXT)
  133.                           (IF (NOT (EQ CONTEXT PROCEDURE-CONTEXT))
  134.                            (FOR-EACH-LOCAL SET-CLOSED-OVER! S-ENV))
  135.                           (LET
  136.                            ((S-ENV@0
  137.                              (RENAME-VARS (PROPER-LISTIFY (CADR .EXP)) S-ENV)))
  138.                            (MAKE-LAMBDA (NEW-NAMES (CADR .EXP) S-ENV@0)
  139.                             (ALPHA-BODY (CDDR .EXP) S-ENV@0 VALUE-CONTEXT)))))))
  140. (SCHI:AT-TOP-LEVEL
  141.   (LOCALLY (DECLARE (SPECIAL VALUE-CONTEXT CLASS/LETREC))
  142.            (DEFINE-ALPHATIZER CLASS/LETREC
  143.                               #'(LAMBDA (.EXP S-ENV CONTEXT)
  144.                                  (LET ((SPECS (CADR .EXP)))
  145.                                   (LET ((VARS (MAPCAR #'CAR SPECS)))
  146.                                    (LET ((S-ENV@0 (RENAME-VARS VARS S-ENV)))
  147.                                     (LET
  148.                                      ((NEW-VARS (NEW-NAMES VARS S-ENV@0)))
  149.                                      (MAKE-LETREC NEW-VARS
  150.                                       (MAPCAR
  151.                                        #'(LAMBDA (SPEC)
  152.                                           (ALPHA (CADR SPEC) S-ENV@0
  153.                                            VALUE-CONTEXT))
  154.                                        SPECS)
  155.                                       (ALPHA-BODY (CDDR .EXP) S-ENV@0
  156.                                        (LOSE CONTEXT)))))))))))
  157. (DEFUN ALPHA-BODY
  158.        (FORMS S-ENV CONTEXT)
  159.        (DECLARE (SPECIAL VALUE-CONTEXT))
  160.        (WITH-VALUES #'(LAMBDA NIL
  161.                               (SCAN-BODY FORMS S-ENV))
  162.                     #'(LAMBDA (SPECS EXPS S-ENV@0)
  163.                        (IF (NULL SPECS)
  164.                         (ALPHA-BEGINIFY EXPS S-ENV@0 CONTEXT)
  165.                         (LET
  166.                          ((NEW-VARS
  167.                            (MAPCAR
  168.                             #'(LAMBDA (SPEC) (MAKE-LOCAL-VARIABLE (CAR SPEC)))
  169.                             SPECS)))
  170.                          (MAPC
  171.                           #'(LAMBDA (SPEC VAR)
  172.                              (DEFINE! S-ENV@0 (CAR SPEC) VAR))
  173.                           SPECS NEW-VARS)
  174.                          (MAKE-LETREC NEW-VARS
  175.                           (MAPCAR
  176.                            #'(LAMBDA (SPEC)
  177.                               (ALPHA (CADR SPEC) (CADDR SPEC) VALUE-CONTEXT))
  178.                            SPECS)
  179.                           (ALPHA-BEGINIFY EXPS S-ENV@0 (LOSE CONTEXT))))))))
  180. (SCHI:SET-VALUE-FROM-FUNCTION 'ALPHA-BODY
  181.                               'SCHEME::ALPHA-BODY)
  182. (SCHI:AT-TOP-LEVEL
  183.   (LOCALLY (DECLARE (SPECIAL VALUE-CONTEXT CLASS/IF))
  184.            (DEFINE-ALPHATIZER CLASS/IF
  185.                               #'(LAMBDA (.EXP S-ENV CONTEXT)
  186.                                  (LET
  187.                                   ((TEST
  188.                                     (ALPHA (CADR .EXP) S-ENV VALUE-CONTEXT))
  189.                                    (CON
  190.                                     (ALPHA (CADDR .EXP) S-ENV (LOSE CONTEXT)))
  191.                                    (ALT
  192.                                     (ALPHA
  193.                                      (LET ((TAIL (CDDDR .EXP)))
  194.                                       (IF (NULL TAIL) 'SCHI:UNSPECIFIED
  195.                                        (CAR TAIL)))
  196.                                      S-ENV (LOSE CONTEXT))))
  197.                                   (MAKE-IF TEST CON ALT))))))
  198. (SCHI:AT-TOP-LEVEL
  199.   (LOCALLY (DECLARE (SPECIAL LVALUE-CONTEXT
  200.                              VALUE-CONTEXT
  201.                              CLASS/SET!))
  202.            (DEFINE-ALPHATIZER CLASS/SET!
  203.                               #'(LAMBDA (.EXP S-ENV CONTEXT) CONTEXT
  204.                                  (LET
  205.                                   ((LHS
  206.                                     (ALPHA (CADR .EXP) S-ENV LVALUE-CONTEXT)))
  207.                                   (IF (SCHI:TRUEP (VARIABLE? LHS))
  208.                                    (MAKE-SET! LHS
  209.                                     (ALPHA (CADDR .EXP) S-ENV VALUE-CONTEXT))
  210.                                    (.ERROR "invalid SET!" .EXP)))))))
  211. (SCHI:AT-TOP-LEVEL
  212.   (LOCALLY (DECLARE (SPECIAL CLASS/BEGIN))
  213.            (DEFINE-ALPHATIZER CLASS/BEGIN
  214.                               #'(LAMBDA (.EXP S-ENV CONTEXT)
  215.                                  (ALPHA-BEGINIFY (CDR .EXP) S-ENV CONTEXT)))))
  216. (DEFUN ALPHA-BEGINIFY
  217.        (EXP-LIST S-ENV CONTEXT)
  218.        (DECLARE (SPECIAL VALUE-CONTEXT
  219.                          TOP-LEVEL-CONTEXT))
  220.        (IF (NULL (CDR EXP-LIST))
  221.            (ALPHA (CAR EXP-LIST) S-ENV CONTEXT)
  222.            (MAKE-BEGIN
  223.              (ALPHA (CAR EXP-LIST)
  224.                     S-ENV
  225.                     (IF (EQ CONTEXT TOP-LEVEL-CONTEXT)
  226.                         CONTEXT
  227.                         VALUE-CONTEXT))
  228.              (ALPHA-BEGINIFY (CDR EXP-LIST)
  229.                              S-ENV
  230.                              (IF (EQ CONTEXT TOP-LEVEL-CONTEXT)
  231.                                  CONTEXT
  232.                                  (LOSE CONTEXT))))))
  233. (SCHI:SET-VALUE-FROM-FUNCTION 'ALPHA-BEGINIFY
  234.                               'SCHEME::ALPHA-BEGINIFY)
  235. (SCHI:AT-TOP-LEVEL
  236.   (LOCALLY
  237.     (DECLARE
  238.       (SPECIAL DEFINE-CONTEXT
  239.                VALUE-CONTEXT
  240.                @WHERE
  241.                TOP-LEVEL-CONTEXT
  242.                CLASS/DEFINE))
  243.     (DEFINE-ALPHATIZER CLASS/DEFINE
  244.                        #'(LAMBDA (FORM S-ENV CONTEXT)
  245.                           (IF (EQ CONTEXT TOP-LEVEL-CONTEXT)
  246.                            (LET
  247.                             ((VAR
  248.                               (ALPHA (DEFINE-FORM-LHS FORM) S-ENV
  249.                                DEFINE-CONTEXT)))
  250.                             (IF (NOT (SCHI:TRUEP (PROGRAM-VARIABLE? VAR)))
  251.                              (.ERROR "This shouldn't happen" FORM))
  252.                             (LET-FLUID @WHERE (PROGRAM-VARIABLE-NAME VAR)
  253.                              #'(LAMBDA NIL
  254.                                 (MAKE-DEFINE VAR
  255.                                  (ALPHA (DEFINE-FORM-RHS FORM) S-ENV
  256.                                   VALUE-CONTEXT)))))
  257.                            (ALPHA
  258.                             (SYNTAX-ERROR
  259.                              "(define ...) disallowed in this context" FORM)
  260.                             S-ENV CONTEXT))))))
  261. (SCHI:AT-TOP-LEVEL
  262.   (LOCALLY (DECLARE (SPECIAL TOP-LEVEL-CONTEXT
  263.                              CLASS/DEFINE-SYNTAX))
  264.            (DEFINE-ALPHATIZER CLASS/DEFINE-SYNTAX
  265.                               #'(LAMBDA (FORM S-ENV CONTEXT)
  266.                                  (IF (EQ CONTEXT TOP-LEVEL-CONTEXT)
  267.                                   (PROGN (PROCESS-DEFINE-SYNTAX FORM S-ENV)
  268.                                    (MAKE-CONSTANT 'SCHEME::DEFINE-SYNTAX
  269.                                     SCHI:TRUE))
  270.                                   (ALPHA
  271.                                    (SYNTAX-ERROR
  272.                                     "(define-syntax ...) disallowed in this context"
  273.                                     FORM)
  274.                                    S-ENV CONTEXT))))))
  275. (DEFUN INITIALIZE-CORE-SYNTAX
  276.        (ENV)
  277.        (DECLARE
  278.          (SPECIAL CLASS/DEFINE-SYNTAX
  279.                   CLASS/DEFINE
  280.                   CLASS/LETREC-SYNTAX
  281.                   CLASS/LET-SYNTAX
  282.                   CLASS/SET!
  283.                   CLASS/BEGIN
  284.                   CLASS/QUOTE
  285.                   CLASS/IF
  286.                   CLASS/LETREC
  287.                   CLASS/LAMBDA))
  288.        (DEFINE! ENV
  289.                 'SCHEME::LAMBDA
  290.                 (MAKE-SPECIAL-OPERATOR CLASS/LAMBDA))
  291.        (DEFINE! ENV
  292.                 'SCHEME::LETREC
  293.                 (MAKE-SPECIAL-OPERATOR CLASS/LETREC))
  294.        (DEFINE! ENV
  295.                 'SCHEME::IF
  296.                 (MAKE-SPECIAL-OPERATOR CLASS/IF))
  297.        (DEFINE! ENV
  298.                 'SCHEME::QUOTE
  299.                 (MAKE-SPECIAL-OPERATOR CLASS/QUOTE))
  300.        (DEFINE! ENV
  301.                 'SCHEME::BEGIN
  302.                 (MAKE-SPECIAL-OPERATOR CLASS/BEGIN))
  303.        (DEFINE! ENV
  304.                 'SCHEME::SET!
  305.                 (MAKE-SPECIAL-OPERATOR CLASS/SET!))
  306.        (DEFINE! ENV
  307.                 'SCHEME::LET-SYNTAX
  308.                 (MAKE-SPECIAL-OPERATOR CLASS/LET-SYNTAX))
  309.        (DEFINE! ENV
  310.                 'SCHEME::LETREC-SYNTAX
  311.                 (MAKE-SPECIAL-OPERATOR CLASS/LETREC-SYNTAX))
  312.        (DEFINE! ENV
  313.                 'SCHEME::DEFINE
  314.                 (MAKE-SPECIAL-OPERATOR CLASS/DEFINE))
  315.        (DEFINE! ENV
  316.                 'SCHEME::DEFINE-SYNTAX
  317.                 (MAKE-SPECIAL-OPERATOR CLASS/DEFINE-SYNTAX)))
  318. (SCHI:SET-VALUE-FROM-FUNCTION 'INITIALIZE-CORE-SYNTAX
  319.                               'SCHEME::INITIALIZE-CORE-SYNTAX)
  320. (LOCALLY (DECLARE (SPECIAL REVISED^4-SCHEME-ENV))
  321.          (SETQ REVISED^4-SCHEME-ENV (MAKE-PROGRAM-ENV 'SCHEME::REVISED^4-SCHEME
  322.                                                       'NIL)))
  323. (SCHI:SET-FUNCTION-FROM-VALUE 'REVISED^4-SCHEME-ENV
  324.                               'SCHEME::REVISED^4-SCHEME-ENV)
  325. (LOCALLY (DECLARE (SPECIAL REVISED^4-SCHEME-ENV))
  326.          (INITIALIZE-CORE-SYNTAX REVISED^4-SCHEME-ENV))
  327. (LOCALLY
  328.   (DECLARE
  329.     (SPECIAL REVISED^4-SCHEME-MODULE
  330.              REVISED^4-SCHEME-ENV
  331.              REVISED^4-SCHEME-SIG))
  332.   (SETQ REVISED^4-SCHEME-MODULE (MAKE-MODULE 'SCHEME::REVISED^4-SCHEME
  333.                                              REVISED^4-SCHEME-SIG
  334.                                              REVISED^4-SCHEME-ENV)))
  335. (SCHI:SET-FUNCTION-FROM-VALUE 'REVISED^4-SCHEME-MODULE
  336.                               'SCHEME::REVISED^4-SCHEME-MODULE)
  337. (DEFUN BUILT-IN
  338.        (NAME)
  339.        (DECLARE (SPECIAL REVISED^4-SCHEME-ENV))
  340.        (PROGRAM-ENV-LOOKUP REVISED^4-SCHEME-ENV NAME))
  341. (SCHI:SET-VALUE-FROM-FUNCTION 'BUILT-IN
  342.                               'SCHEME::BUILT-IN)
  343. (DEFUN READ-FILE
  344.        (FILENAME)
  345.        (LET ((SCHEME::STRING FILENAME)
  346.              (SCHEME::PROC
  347.                #'(LAMBDA (I-PORT)
  348.                   (PROG (L) (SETQ L 'NIL) (GO .LOOP) .LOOP
  349.                    (LET ((FORM (.READ I-PORT)))
  350.                     (IF (EQ FORM SCHI:EOF-OBJECT) (RETURN (REVERSE L))
  351.                      (PROGN (SETQ L (CONS FORM L)) (GO .LOOP))))))))
  352.          (WITH-OPEN-FILE
  353.            (SCHEME::PORT (MERGE-PATHNAMES SCHEME::STRING)
  354.                          :DIRECTION
  355.                          :INPUT)
  356.            (FUNCALL SCHEME::PROC SCHEME::PORT))))
  357. (SCHI:SET-VALUE-FROM-FUNCTION 'READ-FILE
  358.                               'SCHEME::READ-FILE)
  359. (DEFUN NOTE
  360.        (MSG NODE)
  361.        (DECLARE (SPECIAL @WHERE))
  362.        (TERPRI)
  363.        (DISPLAY "** ")
  364.        (DISPLAY MSG)
  365.        (IF (SCHI:TRUEP NODE)
  366.            (PROGN (DISPLAY ": ")
  367.                   (.WRITE
  368.                     (LET-FLUID @WHERE
  369.                                'SCHEME::<NOTE>
  370.                                #'(LAMBDA NIL (SCHEMIFY-TOP NODE))))
  371.                   (TERPRI)
  372.                   (DISPLAY "   Location: ")
  373.                   (.WRITE (FLUID @WHERE))))
  374.        (TERPRI))
  375. (SCHI:SET-VALUE-FROM-FUNCTION 'NOTE 'SCHEME::NOTE)
  376. (DEFUN SYNTAX-ERROR
  377.        (MSG FORM)
  378.        (NOTE MSG FORM)
  379.        (CONS 'SCHI:SCHEME-ERROR
  380.              (CONS (CONS 'SCHEME::QUOTE (LIST MSG))
  381.                    (LIST (CONS 'SCHEME::QUOTE
  382.                                (LIST FORM))))))
  383. (SCHI:SET-VALUE-FROM-FUNCTION 'SYNTAX-ERROR
  384.                               'SCHEME::SYNTAX-ERROR)
  385. (LOCALLY (DECLARE (SPECIAL @UNIQUE-ID))
  386.          (SETQ @UNIQUE-ID (MAKE-FLUID 0)))
  387. (SCHI:SET-FUNCTION-FROM-VALUE '@UNIQUE-ID
  388.                               'SCHEME::@UNIQUE-ID)
  389. (DEFUN WITH-UID-RESET
  390.        (THUNK)
  391.        (DECLARE (SPECIAL @UNIQUE-ID))
  392.        (LET-FLUID @UNIQUE-ID 0 THUNK))
  393. (SCHI:SET-VALUE-FROM-FUNCTION 'WITH-UID-RESET
  394.                               'SCHEME::WITH-UID-RESET)
  395. (DEFUN GENERATE-UID
  396.        NIL
  397.        (DECLARE (SPECIAL @UNIQUE-ID))
  398.        (LET ((UID (FLUID @UNIQUE-ID)))
  399.          (SET-FLUID! @UNIQUE-ID (+ UID 1))
  400.          UID))
  401. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-UID
  402.                               'SCHEME::GENERATE-UID)
  403. (DEFUN MAKE-NAME-FROM-UID
  404.        (NAME UID)
  405.        (DECLARE (SPECIAL @TARGET-PACKAGE))
  406.        (INTERN
  407.          (STRING-APPEND (NAME->STRING NAME)
  408.                         "@"
  409.                         (NUMBER->STRING UID
  410.                                         '(SCHEME::HEUR)))
  411.          (FLUID @TARGET-PACKAGE)))
  412. (SCHI:SET-VALUE-FROM-FUNCTION 'MAKE-NAME-FROM-UID
  413.                               'SCHEME::MAKE-NAME-FROM-UID)
  414. (DEFUN RENAME-VARS
  415.        (NAMES S-ENV)
  416.        (DECLARE (SPECIAL MAKE-LOCAL-VARIABLE))
  417.        (BIND NAMES
  418.              (MAPCAR MAKE-LOCAL-VARIABLE NAMES)
  419.              S-ENV))
  420. (SCHI:SET-VALUE-FROM-FUNCTION 'RENAME-VARS
  421.                               'SCHEME::RENAME-VARS)
  422. (DEFUN NEW-NAMES
  423.        (BVL ENV)
  424.        (MAP-BVL #'(LAMBDA (VAR) (LOOKUP ENV VAR))
  425.                 BVL))
  426. (SCHI:SET-VALUE-FROM-FUNCTION 'NEW-NAMES
  427.                               'SCHEME::NEW-NAMES)
  428. (DEFUN CAR-IS?
  429.        (THING X)
  430.        (IF (CONSP THING)
  431.            (SCHI:TRUE? (EQ (CAR THING) X))
  432.            SCHI:FALSE))
  433. (SCHI:SET-VALUE-FROM-FUNCTION 'CAR-IS? 'SCHEME::CAR-IS?)
  434.